home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / IBMFORT.ZIP;1 / SAMPLE.ZIP / RMULT.FOR
Encoding:
Text File  |  1989-03-01  |  5.7 KB  |  231 lines
  1. C      SUBROUTINES REQUIRED ARE READM, PRINTM, STAND, RCOEF AND SLE.
  2. C
  3. C      ================================================================
  4.        DIMENSION X(100,20),XM(100,10),D(100,3)
  5.        DIMENSION A(20,20),B(20),C(20)
  6.        ND=100
  7.        MD=20
  8.        MM=20
  9. C      INPUT MATRIX HAS N ROWS AND M COLUMNS (N= NO. OF OBS.)
  10. C      AND M=NO. OF VARIABLES
  11.        READ(3,*)N,M
  12.        READ(3,*)((X(I,J),J=1,M),I=1,N)
  13.        WRITE(4,*)' THE INPUT MATRIX IS: '
  14.        WRITE(4,666)((X(I,J),J=1,M),I=1,N)
  15.   666  FORMAT(7F8.1)
  16. C
  17. C      STANDARDIZE INPUT MATRIS AND THEN PRINT
  18. C
  19.        DO 201 I=1,N
  20.        DO 201 J=1,M
  21.        XM(I,J)=X(I,J)
  22.  201   CONTINUE
  23.        CALL STAND(XM,N,M,ND,MD)
  24.        WRITE(4,*)' STANDARDIZED INPUT MATRIX: '
  25.        DO 690 I=1,N
  26.        WRITE(4,667)I,(XM(I,J),J=1,M)
  27.  667   FORMAT(10X,I4,3X,7F8.1)
  28.  690   CONTINUE
  29.        CALL RCOEF(XM,N,M,ND,MD,A,MM)
  30.        WRITE(4,*)'CORRELATION MATRIX. VARIABLE 1 IS Y'
  31.        DO 22 I=1,M
  32.        WRITE(4,668)I,(A(I,J),J=1,M)
  33.  668   FORMAT(10X,I3,3X,7F10.3)
  34.   22   CONTINUE
  35. C
  36. C      SET UP AND SOLVE SIMULTANEOUS EQUATIONS
  37. C
  38.        DO 100 I=2,M
  39.        C(I-1)=A(I,1)
  40.        DO100 J=2,M
  41.        A(I-1,J-1)=A(I,J)
  42.  100   CONTINUE
  43. C
  44. C      SOLVE SLE
  45. C
  46.        CALL SLE(A,C,M-1,MM,1.0E-08)
  47. C
  48. C      CALCULATE PARTIAL REGRESSION COEFFICEINTS
  49. C
  50.        DO 101I=1,M
  51.        A(1,I)=0.0
  52.        A(2,I)=0.0
  53.        DO 101 J=1,N
  54.        A(1,I)=A(1,I)+X(J,I)
  55.        A(2,I)=A(2,I)+X(J,I)**2
  56.  101   CONTINUE
  57.        AA=N
  58.        AB=N-1
  59.        AC=SQRT((A(2,1)-A(1,1)*A(1,1)/AA)/AB)
  60.        B(1)=A(1,1)/AA
  61.        DO 102 I=2,M
  62.        B(I)=C(I-1)*AC/SQRT((A(2,I)-A(1,I)*A(1,I)/AA)/AB)
  63.        B(1)=B(1)-B(I)*A(1,I)/AA
  64.  102   CONTINUE
  65. C
  66. C      CALCULATE ESTIMATED VALUE AND DEVIATION FOR EACH OBSERVATION
  67. C
  68.        DO 103 I=1,N
  69.        D(I,1)=X(I,1)
  70.        D(I,2)=B(1)
  71.        DO 104 J=2,M
  72.        D(I,2)=D(I,2)+B(J)*X(I,J)
  73.  104   CONTINUE
  74.        D(I,3)=D(I,1)-D(I,2)
  75.  103   CONTINUE
  76.        WRITE(4,692)
  77.  692   FORMAT(10X,'COL 1 = Y,  COL 2 =ESTIMATED Y,    COL3 = DEVIATION')
  78.        DO 693 K=1,N
  79.        WRITE(4,669)D(K,1),D(K,2),D(K,3)
  80.  669   FORMAT(12X,F6.2,10X,F10.5,10X,F10.5)
  81.  693   CONTINUE
  82. C
  83. C      PRINT PARTIAL REGRESSION COEFFICIENTS
  84. C
  85.        WRITE(4,*)' REGRESSION COEFFICIENT   1 = CONST. TERM '
  86.        WRITE(4,660)(B(K),K=1,M)
  87.   660  FORMAT(7(E11.4,1X))
  88. C
  89. C      PRINT STANDARD PARTIAL REGRESSION COEFFICIENTS
  90. C
  91.        MMM=M-1
  92.        WRITE(4,697)
  93.   697  FORMAT(' STANDARD PARTIAL REGERSSION COEFFICIENTS ')
  94.        WRITE(4,661)(C(K),K=1,MMM)
  95.   661  FORMAT(6E10.4)
  96. C
  97. C      CALCULATE ERROR MEASURES
  98. C
  99.        SY=0.0
  100.        SYY=0.0
  101.        SYC=0.0
  102.        SYYC=0.0
  103.        DO 105 I=1,N
  104.        SY=SY+D(I,1)
  105.        SYY=SYY+D(I,1)**2
  106.        SYC=SYC+D(I,2)
  107.        SYYC=SYYC+D(I,2)**2
  108.  105   CONTINUE
  109.        SST=SYY-SY*SY/FLOAT(N)
  110.        SSR=SYYC-SYC*SYC/FLOAT(N)
  111.        SSD=SST-SSR
  112.        NDF1=M-1
  113.        AMSR =SSR/FLOAT(NDF1)
  114.        NDF2=N-M
  115.        AMSD=SSD/FLOAT(NDF2)
  116.        R2=SSR/SST
  117.        R=SQRT(R2)
  118.        F=AMSR/AMSD
  119.        NDF3=N-1
  120. C
  121. C      PRINT ERROR HEADINGS AND MEASURES
  122. C
  123.        WRITE(4,680)
  124.  680   FORMAT('SOURCE OF',13X,'SUM OF   DEGREES OF   MEAN')
  125.        WRITE (4,681)
  126.  681   FORMAT('VARIATION', 13X,'SQUARES  FREEDOM    SQUARES     F-TEST')
  127.        WRITE(4,683)SSR,NDF1,AMSR,F
  128.  683   FORMAT(3X,'REGRESSION',5X,E11.4,I6,4X,E11.4,1X,E11.4)
  129.        WRITE(4,684)SSD,NDF2,AMSD
  130.  684   FORMAT(3X,'DEVIATION',6X,E11.4,I6,4X,E11.4)
  131.        WRITE(4,685)SST,NDF3
  132.  685   FORMAT(3X,'TOTAL VARIATION',1X,E11.4,I8,//)
  133.        WRITE(4,686)R2,R
  134.  686   FORMAT(3X,'GOODNESS OF FIT =',F10.4,5X,'CORR. COEFF. = ',F10.4)
  135.        CALL EXIT
  136.        END
  137.        SUBROUTINE SLE(A,B,N,N1,ZERO)
  138.        DIMENSION A(N1,N1),B(N1)
  139.        DO 100 I=1,N
  140.        DIV=A(I,I)
  141.        IF (ABS(DIV)-ZERO)99,99,1
  142.  1     DO 101 J=1,N
  143.        A(I,J)=A(I,J)/DIV
  144.  101   CONTINUE
  145.        B(I)=B(I)/DIV
  146.        DO 102 J=1,N
  147.        IF(I-J)2,102,2
  148.  2     RATIO = A(J,I)
  149.        DO 103 K=I,N
  150.        A(J,K)=A(J,K)-RATIO*A(I,K)
  151.  103   CONTINUE
  152.        B(J)=B(J)-RATIO*B(I)
  153.  102   CONTINUE
  154.  100   CONTINUE
  155.        RETURN
  156.  99    CALL EXIT
  157.        END
  158. C
  159. C      SUBROUTINE TO CALCULATE THE MATRIX OF CORRELATIONS
  160. C      BETWEEN COLUMNS OF DATA MATRIX X
  161. C
  162.        SUBROUTINE RCOEF(X,N,M,N1,M1,A,M2)
  163.        DIMENSION X(N1,M1),A(M2,M2)
  164.        AN=N
  165. C
  166. C      CALCULATE CORRELATION COEFICIENT BETWEEN COLULMNS I AND J
  167. C
  168.        DO 100 I=1,M
  169.        DO 100 J=I,M
  170. C
  171. C      ZERO SUMS
  172. C
  173.        SX1=0.0
  174.        SX2=0.0
  175.        SX1X1=0.0
  176.        SX2X2=0.0
  177.        SX1X2=0.0
  178. C
  179. C      CALCUALTE SUMS, SUMS OF SQUARES AND SUM OF CROSS PROCUCT
  180. C      OF COLUMN I AND J
  181. C
  182.        DO 101 K=1,N
  183.        SX1=SX1+X(K,I)
  184.        SX2=SX2+X(K,J)
  185.        SX1X1=SX1X1+X(K,I)**2
  186.        SX2X2=SX2X2+X(K,J)**2
  187.        SX1X2=SX1X2+X(K,I)*X(K,J)
  188.  101   CONTINUE
  189. C
  190. C      CALCULATE CORRELATION COEFFICIENT AND STORE IN MATRIX A
  191. C
  192.        RR1=(SX1X2-SX1*SX2/AN)
  193.        RR2=SQRT((SX1X1-SX1*SX1/AN)*(SX2X2-SX2*SX2/AN))
  194.        R=RR1/RR2
  195.        A(I,J)=R
  196.        A(J,I)=R
  197.  100   CONTINUE
  198.        RETURN
  199.        END
  200. C
  201. C      SUBROUTINE TO STANDARDIZE THE COLUMNS OF A DATA MATRIX
  202. C
  203.        SUBROUTINE STAND(X,N,M,N1,M1)
  204.        DIMENSION X(N1,M1)
  205.        WRITE(*,*)'SUCCESSFUL ENTER'
  206. C
  207. C      STANDARDIZE EACH COLUMN OF THE MATRIX
  208. C
  209.        DO 100 I=1,M
  210. C
  211. C      CALCULATE MEAN AND STANDARE DEVIATION OF COLUMN
  212. C
  213.        SX=0.0
  214.        SXX=0.0
  215.        DO101 J=1,N
  216.        SX=SX+X(J,I)
  217.        SXX=SXX+X(J,I)**2
  218.  101   CONTINUE
  219.        XM=SX/FLOAT(N)
  220.        SD=SQRT((SXX-SX*SX/FLOAT(N))/FLOAT(N-1))
  221. C
  222. C      SUBTRACT MEAN FROM EACH ELEMENT IN COLUMN, THEN
  223. C      DIVIDE RESULT BY THE STANDARD DEVIATION.
  224. C
  225.        DO 102 J=1,N
  226.        X(J,I)=(X(J,I)-XM)/SD
  227.  102   CONTINUE
  228.  100   CONTINUE
  229.        RETURN
  230.        END
  231.